home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / gnu / GNU_TILE_FORTH.lha / src / compiler.v next >
Text File  |  1992-05-19  |  5KB  |  247 lines
  1. /*
  2.   C BASED FORTH-83 MULTI-TASKING KERNEL: COMPILER EXTENSION LEVEL DEFINITIONS
  3.  
  4.   Copyright (C) 1988-1990 by Mikael R.K. Patel
  5.  
  6.   Computer Aided Design Laboratory (CADLAB)
  7.   Department of Computer and Information Science
  8.   Linkoping University
  9.   S-581 83 LINKOPING
  10.   SWEDEN
  11.  
  12.   Email: mip@ida.liu.se
  13.  
  14.   Started on: 30 June 1988
  15.  
  16.   Last updated on: 12 September 1990
  17.  
  18.   Dependencies:
  19.        (cc) kernel.c, kernel.h
  20.  
  21.   Description:
  22.     Compiler extension vocabulary of the tile forth multi-tasking
  23.     kernel.
  24.  
  25.   Copying:
  26.        This program is free software; you can redistribute it and/or modify
  27.        it under the terms of the GNU General Public License as published by
  28.        the Free Software Foundation; either version 1, or (at your option)
  29.        any later version.
  30.  
  31.        This program is distributed in the hope that it will be useful,
  32.        but WITHOUT ANY WARRANTY; without even the implied warranty of
  33.        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  34.        GNU General Public License for more details.
  35.  
  36.        You should have received a copy of the GNU General Public License
  37.        along with this program; see the file COPYING.  If not, write to
  38.        the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  39.  
  40. */
  41.  
  42. VOID doparenbranch()
  43. {
  44.     fbranch(*ip);
  45. }
  46.  
  47. COMPILATION_CODE(parenbranch, forth, "(branch)", doparenbranch);
  48.  
  49. VOID doparenqbranch()
  50. {
  51.     BOOL flag;
  52.  
  53.     /* Pop flag */
  54.     flag = spop(BOOL);
  55.     
  56.     /* Check flag on top of stack and branch if false */
  57.     if (flag)
  58.     fskip();
  59.     else
  60.     fbranch(*ip);
  61. }
  62.  
  63. COMPILATION_CODE(parenqbranch, parenbranch, "(?branch)", doparenqbranch);
  64.  
  65. VOID doparendo()
  66. {
  67.     /* Build a loop frame on return stack */
  68.     rpush(ip++);
  69.     rpush(spop(INT32));
  70.     rpush(spop(INT32));
  71. }
  72.  
  73. COMPILATION_CODE(parendo, parenqbranch, "(do)", doparendo);
  74.  
  75. VOID doparenqdo()
  76. {
  77.     /* Check if the start and stop value are equal */
  78.     if (tos.INT32 == snth(0).INT32) {
  79.  
  80.     /* If equal then branch over the loop block */
  81.     sndrop(1);
  82.     fbranch(*ip);
  83.     }
  84.     else {
  85.  
  86.     /* else build a loop frame on the return stack */
  87.     rpush(ip++);
  88.     rpush(spop(INT32));
  89.     rpush(spop(INT32));
  90.     }
  91. }
  92.  
  93. COMPILATION_CODE(parenqdo, parendo, "(?do)", doparenqdo);
  94.  
  95. VOID doparenloop()
  96. {
  97.     /* Increment the index by one and check if within loop range */
  98.     rnth(1) += 1;
  99.     if (rnth(0) > rnth(1)) {
  100.  
  101.     /* Branch if still within range */
  102.     fbranch(*ip);
  103.     return;
  104.     }
  105.  
  106.     /* Else remove the loop frame from the return stack and skip */
  107.     rndrop(3);
  108.     fskip();
  109. }
  110.  
  111. COMPILATION_CODE(parenloop, parenqdo, "(loop)", doparenloop);
  112.  
  113. VOID doparenplusloop()
  114. {
  115.     register INT32 d;
  116.  
  117.     /* Pop the decrement value */
  118.     d = spop(INT32);
  119.  
  120.     /* Increment the index with the top of stack value */
  121.     rnth(1) += d;
  122.  
  123.     /* Check direction and if the index is still within the loop range */
  124.     if (d > 0) {
  125.     if (rnth(0) > rnth(1)) {
  126.         fbranch(*ip);
  127.         return;
  128.     }
  129.     }
  130.     else {
  131.     if (rnth(0) < rnth(1)) {
  132.         fbranch(*ip);
  133.         return;
  134.     }
  135.     }
  136.  
  137.     /* Else remove the loop frame from the return stack and skip */
  138.     rndrop(3);
  139.     fskip();
  140. }
  141.  
  142. COMPILATION_CODE(parenplusloop, parenloop, "(+loop)", doparenplusloop);
  143.  
  144.  
  145. /* COMPILATION LITERALS */
  146.  
  147. VOID doparenliteral()
  148. { 
  149.     spush(*ip++, INT32);
  150. }
  151.  
  152. COMPILATION_CODE(parenliteral, parenplusloop, "(literal)", doparenliteral);
  153.  
  154. VOID doparendotquote()
  155. {
  156.     (VOID) fprintf(io_outf, "%s", *ip++);
  157. }
  158.  
  159. COMPILATION_CODE(parendotquote, parenliteral, "(.\")", doparendotquote);
  160.  
  161. VOID doparenabortquote()
  162. {
  163.     BOOL flag;
  164.  
  165.     /* Pop flag from top of stack */
  166.     flag = spop(BOOL);
  167.     
  168.     /* Check flag on top of stack. If true then abort and give message */
  169.     if (flag) {
  170.     doparendotquote();
  171.     docr();
  172.     doabort();
  173.     }
  174.     else fskip();
  175. }
  176.  
  177. COMPILATION_CODE(parenabortquote, parendotquote, "(abort\")", doparenabortquote);
  178.  
  179. VOID doparensemicolon()
  180. {
  181.     fsemicolon();
  182. }
  183.  
  184. COMPILATION_CODE(parensemicolon, parendotquote, "(;)", doparensemicolon);
  185.  
  186. VOID doparendoes()
  187. {
  188.     fdoes();
  189. }
  190.  
  191. COMPILATION_CODE(parendoes, parensemicolon, "(does>)", doparendoes);
  192.  
  193.  
  194. /* THREADING PRIMITIVES */
  195.  
  196. VOID dothread()
  197. {
  198.     *dp++ = spop(INT32);
  199. }
  200.  
  201. NORMAL_CODE(thread, parendoes, "thread", dothread);
  202.  
  203. VOID dounthread()
  204. {
  205.     unary(*(PTR32), INT32);
  206. }
  207.  
  208. NORMAL_CODE(unthread, thread, "unthread", dounthread);
  209.  
  210.  
  211. VOID doforwardmark()
  212. {
  213.     dohere();
  214.     spush(0, INT32);
  215.     docomma();
  216. }
  217.  
  218. COMPILATION_CODE(forwardmark, unthread, ">mark", doforwardmark);
  219.  
  220. VOID dobackwardmark()
  221. {
  222.     dohere();
  223. }
  224.  
  225. COMPILATION_CODE(backwardmark, forwardmark, "<mark", dobackwardmark);
  226.  
  227. VOID doforwardresolve()
  228. {
  229.     dohere();
  230.     doover();
  231.     dominus();
  232.     doswap();
  233.     dostore();
  234. }
  235.  
  236. COMPILATION_CODE(forwardresolve, backwardmark, ">resolve", doforwardresolve);
  237.  
  238. VOID dobackwardresolve()
  239. {
  240.     dohere();
  241.     dominus();
  242.     docomma();
  243. }
  244.  
  245. COMPILATION_CODE(backwardresolve, forwardresolve, "<resolve", dobackwardresolve);
  246.  
  247.